home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / languages / obrn-a_1.5_lib.lha / oberon-a / source2.lha / Source / ProjectOberon / Fonts.mod < prev    next >
Encoding:
Text File  |  1995-01-26  |  3.8 KB  |  139 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: Fonts.mod $
  4.   Description: Port of the Project Oberon Fonts module
  5.  
  6.    Created by: J. Gutknecht
  7.     Ported by: fjc (Frank Copeland)
  8.     $Revision: 1.12 $
  9.       $Author: fjc $
  10.         $Date: 1995/01/26 00:48:34 $
  11.  
  12.   Copyright © 1990-1993, ETH Zuerich
  13.   Copyright © 1994, Frank Copeland.
  14.   This file is part of the Oberon-A Library.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17. ***************************************************************************)
  18.  
  19. <* STANDARD- *> <* MAIN- *>
  20.  
  21. MODULE Fonts;
  22.  
  23. IMPORT
  24.   SYS := SYSTEM, Kernel, gfx := Graphics, df := DiskFont,
  25.   str := Strings, str2 := Strings2;
  26.  
  27. TYPE
  28.  
  29.   Name * = ARRAY 32 OF CHAR;
  30.  
  31.   Font * = POINTER TO FontDesc;
  32.   FontDesc * = RECORD
  33.     name * : Name;
  34.     height * : INTEGER;
  35.     textAttr * : gfx.TextAttrPtr;
  36.     textFont * : gfx.TextFontPtr;
  37.     next : Font;
  38.   END; (* FontDesc *)
  39.  
  40. VAR
  41.  
  42.   Default *, First : Font;
  43.   nofFonts : INTEGER;
  44.  
  45. (*------------------------------------*)
  46. PROCEDURE This * (name : ARRAY OF CHAR) : Font;
  47. (*
  48.  *  Opens the font described by name and returns a descriptor for it.
  49.  *  name is required to be in the common Amiga notation for fonts, namely:
  50.  *
  51.  *    <font name>/<font size>
  52.  *
  53.  *  For example: "topaz/8" refers to the size 8 version of the topaz font.
  54.  *)
  55.  
  56.   VAR
  57.     F : Font; fontName : Name; len, pos : LONGINT; size, i : INTEGER;
  58.     ch : CHAR; textAttr : gfx.TextAttrPtr; textFont : gfx.TextFontPtr;
  59.  
  60. <*$CopyArrays-*>
  61. BEGIN (* This *)
  62.   F := First; WHILE (F # NIL) & (name # F.name) DO F := F.next END;
  63.   IF F = NIL THEN
  64.     COPY (name, fontName);
  65.     pos := str2.FindChar ("/", fontName, 0);
  66.     IF pos >= 0 THEN
  67.       len := str.Length (fontName);
  68.       IF len > (pos + 1) THEN
  69.         i := SHORT (pos) + 1; size := 0; ch := fontName [i];
  70.         WHILE (i < len) & (ch >= "0") & (ch <= "9") DO
  71.           size := (size * 10) + (ORD (ch) - ORD ("0"));
  72.           INC (i); ch := fontName [i]
  73.         END; (* WHILE *)
  74.         IF i = len THEN
  75.           fontName [pos] := 0X; str.Append (".font", fontName);
  76.           NEW (textAttr);
  77.           SYS.NEW (textAttr.name, str.Length (fontName) + 1);
  78.           COPY (fontName, textAttr.name^);
  79.           textAttr.ySize := size;
  80.           textAttr.style := gfx.normal;
  81.           textAttr.flags := {gfx.diskFont};
  82.           textFont := df.OpenDiskFont (textAttr^);
  83.           IF textFont # NIL THEN
  84.             NEW (F);
  85.             COPY (name, F.name); F.height := size;
  86.             F.textAttr := textAttr; F.textFont := textFont;
  87.             F.next := First; First := F
  88.           ELSE
  89.             SYS.DISPOSE (textAttr.name); SYS.DISPOSE (textAttr);
  90.             F := Default
  91.           END; (* ELSE *)
  92.         ELSE
  93.           F := Default
  94.         END; (* ELSE *)
  95.       ELSE
  96.         F := Default
  97.       END; (* ELSE *)
  98.     ELSE
  99.       F := Default
  100.     END; (* ELSE *)
  101.   END; (* IF *)
  102.   RETURN F
  103. END This;
  104.  
  105. (*------------------------------------*)
  106. PROCEDURE* Cleanup (VAR rc : LONGINT);
  107.  
  108.   VAR F : Font;
  109.  
  110. BEGIN (* Cleanup *)
  111.   F := First;
  112.   WHILE F # Default DO
  113.     IF F.textFont # NIL THEN gfx.CloseFont (F.textFont) END;
  114.     F := F.next
  115.   END;
  116. END Cleanup;
  117.  
  118. (*------------------------------------*)
  119. PROCEDURE GetDefault ();
  120.  
  121.   VAR defFont : gfx.TextFontPtr; ta : gfx.TextAttrPtr;
  122.  
  123. BEGIN (* GetDefault *)
  124.   defFont := gfx.base.defaultFont;
  125.   NEW (ta);
  126.   ta.name := defFont.message.node.name; ta.ySize := defFont.ySize;
  127.   ta.style := defFont.style; ta.flags := defFont.flags;
  128.   NEW (Default);
  129.   COPY (defFont.message.node.name^, Default.name);
  130.   Default.height := defFont.ySize; Default.textAttr := ta;
  131.   Default.textFont := defFont; Default.next := NIL;
  132. END GetDefault;
  133.  
  134. BEGIN (* Fonts *)
  135.   ASSERT (df.base # NIL, 100);
  136.   GetDefault (); First := Default; nofFonts := 1;
  137.   Kernel.SetCleanup (Cleanup)
  138. END Fonts.
  139.